;;; -*- Mode:LISP; Package:user; Base:10; Readtable:CL -*-


(defun destructive (n m)
  (let ((l (do ((i 10. (1- i))
                (a () (push () a)))
               ((= i 0) a))))
    (do ((i n (1- i)))
        ((= i 0))
      (cond ((null (car l))
             (do ((l l (cdr l)))
                 ((null l))
               (or (car l)
                   (rplaca l (ncons ())))
               (nconc (car l)
                      (do ((j m (1- j))
                           (a () (push () a)))
                          ((= j 0) a)))))
            (t
             (do ((l1 l (cdr l1))
                  (l2 (cdr l) (cdr l2)))
                 ((null l2))
               (rplacd (do ((j (floor (length (car l2)) 2) (1- j))
                            (a (car l2) (cdr a)))
                           ((= j 0) a)
                         (rplaca a i))
                       (let ((n (floor (length (car l1)) 2)))
                         (cond ((= n 0) (rplaca l1 ())
                                        (car l1))
                               (t
                                (do ((j n (1- j))
                                     (a (car l1) (cdr a)))
                                    ((= j 1)
                                     (prog1 (cdr a)
                                            (rplacd a ())))
                                  (rplaca a i))))))))))))

;;;;THIS MUST BE COMPILED WITH HARDEBECK COMPILER!!!!!
(defun test-destructive ()
  (hw:write-microsecond-clock (hw:unboxed-constant 0))
  (li:error "DESTRUCTIVE complete."
         (destructive 600. 50.)
         (hw:read-microsecond-clock))
  (loop))
